home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0034_PCX *IN* Pascal!.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-25  |  4.3 KB  |  184 lines
  1.  
  2.  
  3.  > Does anyone have a program (not necessarily source) that will
  4.  > take a full
  5.  > screen GIF or PCX or whatever graphic format and convert it into
  6.  > something I can load in Pascal?  Or even a graphic editor that
  7.  
  8. You can load a .PCX in pascal! No conversion needed. Here is some source.
  9.  
  10. { MCGA PCX decode by Bas van Gaalen, Holland, PD }
  11. { Modified to use virtual screen/pointers by Ricky Booth, USA, PD }
  12.  
  13.  
  14. {$M 65520, 4096, 655360}
  15. {$I-}
  16.  
  17. program pcx_view;
  18.  
  19. uses
  20.   crt;
  21.  
  22. type
  23.   pcxheader = record
  24.     manufacturer,version,encoding,bits_per_pixel : byte;
  25.     xmin,ymin,xmax,ymax,hres,vres : word;
  26.     palette : array[0..47] of byte;
  27.     reserved : byte;
  28.     color_planes : byte;
  29.     bytes_per_line : word;
  30.     palette_type : word;
  31.     filler : array[0..57] of byte;
  32.   end;
  33.  
  34. var
  35.   pcxfile : file;
  36.   header : pcxheader;
  37.  
  38. {----------------------------------------------------------------------------}
  39.  
  40. procedure error(errstr : string);
  41. begin
  42.   writeln(errstr);
  43.   halt;
  44. end;
  45.  
  46. {----------------------------------------------------------------------------}
  47.  
  48. function validpcx : boolean;
  49. begin
  50.   seek(pcxfile,0);
  51.   blockread(pcxfile,header,sizeof(header));
  52.   with header do validpcx := (manufacturer = 10) and (version = 5) and
  53.     (bits_per_pixel = 8) and (color_planes = 1);
  54. end;
  55.  
  56. {----------------------------------------------------------------------------}
  57.  
  58. function validpal : boolean;
  59. var v : byte;
  60. begin
  61.   seek(pcxfile,filesize(pcxfile)-769);
  62.   blockread(pcxfile,v,1);
  63.   validpal := v = $0c;
  64. end;
  65.  
  66. {----------------------------------------------------------------------------}
  67.  
  68. procedure setvideo(md : word); assembler;
  69. asm
  70.   mov ax,md
  71.   int 10h
  72. end;
  73.  
  74. {----------------------------------------------------------------------------}
  75.  
  76. CONST VGA = $a000;  (* This sets the constant VGA to the segment of the
  77.                        VGA screen.                                      *)
  78.  
  79. Type Virtual = Array [1..64000] of byte;  { The size of our Virtual Screen }
  80.      VirtPtr = ^Virtual;                  { Pointer to the virtual screen }
  81.  
  82. VAR Virscr : VirtPtr;                     { Our first Virtual screen }
  83.     Vaddr  : word;                        { The segment of our virtual screen}
  84.  
  85. procedure setpal;
  86. var pal : array[0..767] of byte;
  87. begin
  88.   seek(pcxfile,filesize(pcxfile)-768);
  89.   blockread(pcxfile,pal,768);
  90.   asm
  91.     cld
  92.     xor di,di
  93.     xor bx,bx
  94.    @L1:
  95.     mov dx,03c8h
  96.     mov ax,bx
  97.     out dx,al
  98.     inc dx
  99.     mov cx,3
  100.    @L2:
  101.     mov al,byte ptr pal[di]
  102.     shr al,1
  103.     shr al,1
  104.     out dx,al
  105.     inc di
  106.     loop @L2
  107.     inc bx
  108.     cmp bx,256
  109.     jne @L1
  110.   end;
  111. end;
  112.  
  113. {----------------------------------------------------------------------------}
  114.  
  115. Procedure SetUpVirtual;
  116. BEGIN
  117.   GetMem (VirScr,64000);
  118.   vaddr := seg (virscr^);
  119. END;
  120.  
  121. procedure unpack;
  122. var gofs,j : word; i,k,v,loop : byte;
  123. begin
  124.   seek(pcxfile,128);
  125.   gofs := 0;
  126.   for i := 0 to header.ymax-header.ymin+1 do begin
  127.     j := 0;
  128.     while j < header.bytes_per_line do begin
  129.       blockread(pcxfile,v,1);
  130.       if (v and 192) = 192 then begin
  131.         loop := v and 63;
  132.         inc(j,loop);
  133.         blockread(pcxfile,v,1);
  134.         for k := 1 to loop do begin
  135.           Mem[Vaddr:gofs] := v;
  136.           inc(gofs);
  137.         end;
  138.       end
  139.       else begin
  140.         Mem[Vaddr:gofs] := v;
  141.         inc(gofs);
  142.         inc(j);
  143.       end;
  144.     end;
  145.   end;
  146. end;
  147.  
  148. Procedure WaitRetrace; assembler;
  149. label
  150.   l1, l2;
  151. asm
  152.     mov dx,3DAh
  153. l1:
  154.     in al,dx
  155.     and al,08h
  156.     jnz l1
  157. l2:
  158.     in al,dx
  159.     and al,08h
  160.     jz  l2
  161. end;
  162.  
  163. {----------------------------------------------------------------------------}
  164.  
  165. begin
  166.   SetUpVirtual; (*initilizes the pointers*)
  167.   if paramstr(1) = '' then error('Enter filename on commandline.');
  168.   assign(pcxfile,paramstr(1));
  169.   reset(pcxfile,1);
  170.   if ioresult <> 0 then error(paramstr(1)+' not found.');
  171.   if not validpcx then error('Not a 256 color PCX file.');
  172.   if not validpal then error('Palette corrupt.');
  173.   Writeln('Decoding Image...');
  174.   Unpack;
  175.   Setvideo($13);
  176.   Setpal;
  177.   Move(Virscr^,MEM[VGA:0],64000); (*Stick the virtual page to the vga mem*)
  178.   repeat until keypressed;
  179.   While keypressed do readln;
  180.   setvideo(3);
  181.   close(pcxfile);
  182.   FreeMem (VirScr,64000); (*Free up virtual memory*)
  183. end.
  184.